﻿module Engine where

import Data.Maybe
import Data.List.Split
import Data.List
import Data.Char
import Data.Int
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Read as T

type WordDict = Map.Map T.Text [Int]

showAccents :: [Int] -> String
showAccents []       = ""
showAccents (x:xs)   = show x ++ showl xs
                        where showl []     = ""
                              showl (x:xs) = "," ++ show x ++ showl xs
                
readAccents :: String -> [Int]
readAccents [] = []
readAccents text = let ttext = T.pack text
                       tvalues = T.splitOn (T.pack ",") ttext
                   in maybeAccentsToVals (map maybeRead tvalues)

maybeRead :: T.Text -> Maybe Int
maybeRead s = case T.decimal s of
    Left _  -> Nothing
    Right i -> Just $ fst i
    
maybeAccentsToVals :: [Maybe Int] -> [Int]    
maybeAccentsToVals [] = []
maybeAccentsToVals (x:xs) = case x of 
                                Nothing -> maybeAccentsToVals xs
                                Just v -> v : maybeAccentsToVals xs                                         
                    
parseToEntries :: [T.Text] -> [(T.Text, [Int])]
parseToEntries [] = []
parseToEntries (x:xs) = let key_value = T.split (==':') x
                            accents = T.splitOn (T.pack ",") (last key_value)
                            values = map maybeRead accents
                        in (makeDictEntry (head key_value) values)++ parseToEntries xs 
                        where makeDictEntry :: T.Text -> [Maybe Int] ->[(T.Text, [Int])] 
                              makeDictEntry key mvals = let vals = maybeAccentsToVals mvals
                                                        in case vals of
                                                            [] -> []
                                                            m -> [(key, m)] 
  
dictToText :: WordDict -> LT.Text
dictToText dict = let entries = Map.toList dict
                  in makeText entries
                  where makeText :: [(T.Text, [Int])] -> LT.Text
                        makeText [] = LT.empty
                        makeText (x:xs) = let key = LT.fromStrict (fst x)
                                              value = LT.fromStrict (T.pack(showAccents (snd x)))
                                              entry = LT.concat[key, (LT.singleton ':'), value, (LT.singleton '\n')]
                                          in LT.append entry (makeText xs)
  
populateDict :: WordDict -> String -> String -> WordDict
populateDict dict keyStr valuesStr = let accents = readAccents valuesStr
                                     in case accents of
                                        [] -> dict
                                        m -> Map.insert (T.pack keyStr) m dict
  
isVowel c = c `elem` ['а', 'о', 'у', 'е', 'и', 'ё', 'ы', 'э', 'ю', 'я']

partsToLine :: [T.Text] -> T.Text
partsToLine [] = T.empty
partsToLine (x:xs) = T.append (T.snoc x '/') (partsToLine xs)

wordToSyllables ::  WordDict -> T.Text -> T.Text
wordToSyllables dict word = let accentPos = searchAccent dict word
                                sword = T.unpack word
                            in T.pack $ wordToSyllablesImpl sword accentPos 0
                            where wordToSyllablesImpl :: String -> Int -> Int -> String
                                  wordToSyllablesImpl [] _ _ = []
                                  wordToSyllablesImpl (x:xs) accentPos i = procLetter x accentPos i ++ wordToSyllablesImpl xs accentPos (i + 1)
                                  
                                  procLetter :: Char -> Int -> Int -> String
                                  procLetter c accentPos index | isVowel c && index /= accentPos = "-"
                                                     | isVowel c && index == accentPos = "o"
                                                     | otherwise = []                                                               
                                            
processLine :: WordDict -> T.Text -> T.Text
processLine dict str = let words = T.words str
                           syllables = map (wordToSyllables dict) words                          
                       in partsToLine syllables
                                            
addNumbers :: [T.Text] -> [T.Text]
addNumbers [] = []
addNumbers lines = addNumbersImpl lines 0
                   where addNumbersImpl :: [T.Text] -> Int -> [T.Text]
                         addNumbersImpl [] _ = []
                         addNumbersImpl (x:xs) index = [(addNumber x (index + 1))] ++ addNumbersImpl xs (index + 1)
                            where addNumber :: T.Text -> Int -> T.Text
                                  addNumber s i = T.concat [T.pack (show i), T.pack ". ", s]

calcStatictics :: T.Text -> WordDict -> T.Text
calcStatictics text dict = let lines = T.lines text
                               newLines = map (processLine dict) lines
                               numLines = addNumbers newLines
                           in T.unlines numLines
                      
searchAccent :: WordDict -> T.Text -> Int
searchAccent dict word = let sword = T.toLower word
                             entry = Map.lookup sword dict
                         in case entry of
                            Nothing -> -1
                            Just match -> (head match) - 1
                           
